home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / arith2.com / ENCODE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-02-27  |  6.1 KB  |  217 lines
  1. PROGRAM encode;
  2.  
  3. {$F+}
  4.  
  5.         { ------------------------------------------------------------------
  6.  
  7.           This program and its associates implement in Turbo Pascal v5
  8.           the aritmetic encoding/decoding algorithms presented in the papers
  9.  
  10.           "Arithmetic Coding for Data Compression"
  11.  
  12.                    by Ian     H. Witten
  13.                       Radford M. Neal
  14.                       John    G. Cleary
  15.  
  16.           pp 520 - 540 of June 1987 Communications of the ACM
  17.  
  18.           and
  19.  
  20.           "An Adaptive Dependency Source Model For Data Compression"
  21.  
  22.                    by David M. Abrahamson
  23.  
  24.           pp 77 - 83 of January 1989 Communications of the ACM
  25.  
  26.           ------------------------------------------------------------------
  27.  
  28.           Implemented by Ken Westerback : CompuServe 73547,3520
  29.  
  30.           version 1.0 released 89/02/19
  31.           version 2.0 released 89/02/27
  32.  
  33.           These programs, units and associated documentation are released
  34.           into the public domain to be used and abused as your whims
  35.           dictate.
  36.  
  37.           Feel free to distribute/incorporate/improve as desired.
  38.  
  39.           >>>>> Use at your own risk! <<<<<
  40.  
  41.           Comments and suggestions welcome via CompuServe.
  42.  
  43.           ------------------------------------------------------------------
  44.         }
  45.  
  46.  
  47.         USES overlay
  48.             ,dos
  49.             ,arith_en  { arithmetic encoding implementation      }
  50.             ,fix_mod   { fixed coding model                      }
  51.             ,adap_mod  { adaptive coding model                   }
  52.             ,adp_mod   { adaptive dependency source coding model }
  53.             ;
  54.  
  55. {$O fix_mod  }
  56. {$O adap_mod }
  57. {$O adp_mod  }
  58.  
  59. var    symbol : integer;      { symbol for character being encoded       }
  60.       encodee : file;         { file to encode                           }
  61.      chars_in : longint;      { characters read from encodee             }
  62.     chars_out : longint;      { (bits_sent + 7) div 8                    }
  63.    chars_left : longint;      { characters left to read from encodee     }
  64.  
  65.      char_buf : array[ 0..2047] of char; { chunks we read encodee in }
  66.  chars_in_buf : word;
  67.             i : word;
  68.  
  69.    model_name : string;
  70.  
  71. select_symbol : function  (     ch : char    ) : integer;
  72. update_model  : procedure ( symbol : integer )          ;
  73.  
  74.  
  75. procedure open_files;
  76.  
  77.           var                      s : pathstr;
  78.               param1, param2, param3 : string;
  79.  
  80.           begin
  81.  
  82.           { must have three parameters - in/out files and model to use }
  83.  
  84.           if ( paramcount < 3 ) then
  85.              begin
  86.              writeln ;
  87.              writeln ( 'usage : encode <model> <input file> <output file>' );
  88.              writeln;
  89.              halt;
  90.              end;
  91.  
  92.           param1 := paramstr ( 1 );
  93.           param2 := paramstr ( 2 );
  94.           param3 := paramstr ( 3 );
  95.  
  96.           writeln ;
  97.           write   ( '"', param2, '" will be encoded as "', param3, '"' );
  98.  
  99.           start_encoding ( param3, param1[ 1 ] );
  100.  
  101.           { second parameter is file to encode }
  102.  
  103.           s := fsearch ( param2, '' );
  104.  
  105.           if s <> '' then
  106.              assign ( encodee, s )
  107.           else
  108.              begin
  109.              writeln ;
  110.              writeln ( 'encode : can''t find file "', paramstr(1), '"' );
  111.              writeln;
  112.              halt;
  113.              end;
  114.  
  115.           Reset ( encodee, 1 );
  116.  
  117.           chars_left := filesize ( encodee );
  118.           chars_in   := 0;
  119.  
  120.           { third parameter is desired name of encoded file. }
  121.           {                                                   }
  122.           { note : will write over any file of same name!     }
  123.  
  124.           ovrinit ( 'encode.ovr' );
  125.  
  126.           if ovrresult <> ovrok then
  127.              begin
  128.              writeln;
  129.              writeln ( 'encode : overinit failed (', ovrresult, ')' );
  130.              writeln;
  131.              halt;
  132.              end;
  133.  
  134.           case param1[ 1 ] of
  135.  
  136.              'f' : begin
  137.                    model_name    := fix_mod.model_name;
  138.                    fix_mod.start_model;
  139.                    select_symbol := fix_mod.select_symbol;
  140.                    update_model  := fix_mod.update_model;
  141.                    end;
  142.  
  143.              'a' : begin
  144.                    model_name    := adap_mod.model_name;
  145.                    adap_mod.start_model;
  146.                    select_symbol := adap_mod.select_symbol;
  147.                    update_model  := adap_mod.update_model;
  148.                    end;
  149.  
  150.              'd' : begin
  151.                    model_name    := adp_mod.model_name;
  152.                    adp_mod.start_model;
  153.                    select_symbol := adp_mod.select_symbol;
  154.                    update_model  := adp_mod.update_model;
  155.                    end;
  156.  
  157.              else  begin
  158.                    writeln;
  159.                    writeln ( 'encode : invalid model "', param1[ 1 ], '"' );
  160.                    writeln;
  161.                    halt;
  162.                    end;
  163.  
  164.              end; { model case }
  165.  
  166.           writeln ( ' using ', model_name );
  167.  
  168.           end; { open files }
  169.  
  170. procedure close_files;
  171.           begin
  172.  
  173.           chars_out := done_encoding;
  174.  
  175.           close ( encodee );
  176.  
  177.           end; { close_files }
  178.  
  179. BEGIN
  180.  
  181. writeln ;
  182. writeln ( 'TPascal Arithmetic Coding, by Ken Westerback, version 2.0 89/02/27' );
  183.  
  184. open_files;
  185.  
  186. while not eof ( encodee ) do
  187.       begin
  188.  
  189.       chars_in_buf := 2048;
  190.       if chars_left < 2048 then chars_in_buf := chars_left;
  191.  
  192.       dec ( chars_left, chars_in_buf );
  193.  
  194.       blockread ( encodee, char_buf, chars_in_buf, chars_in_buf );
  195.  
  196.       inc ( chars_in, chars_in_buf );
  197.  
  198.       for i := 0 to chars_in_buf-1 do
  199.           begin
  200.           symbol := select_symbol ( char_buf[ i ] );
  201.           encode_symbol ( symbol );
  202.           update_model ( symbol );
  203.           end;
  204.  
  205.       end;
  206.  
  207. close_files;
  208.  
  209. writeln ;
  210. writeln ( '   characters read    : ', chars_in  );
  211. writeln ( '   characters written : ', chars_out );
  212. writeln ;
  213. writeln ( '   ', (100 - (chars_out/chars_in)*100):4:2, ' % compression' );
  214. writeln ;
  215.  
  216. end. { arithmetic encoding of a file }
  217.